home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HAM Radio 1997
/
HAM Radio 1997.iso
/
vcls
/
handles
/
handles.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-04-08
|
25KB
|
771 lines
unit Handles;
{ A first attempt at a StretchHandle component for Delphi... it "owns"
another component via the FChildControl property, and will resize or
move its Child along with itself when it is dragged or stretched at
runtime with the left mouse button. The component is sized 2 pixels
larger on each side than its FChildControl, and the grab handles are
5x5. It will shrink to 5x5.
Any suggestions for improvement would be appreciated...
Revised 7/1/95: Used MouseUp, MouseDown, MouseMove override rather than
message handlers for mouse events.
Changed name of EControlInvalid to EBadChild (sorry!).
Added Child property (read/write, equivalent to using
Attach/Detach methods).
Fixed bug in IsAttached.
Added BringToFront & SendToBack methods to correctly
manipulate ChildControl
Added arrow keys to move a selected control in one-pixel
increments.
Added a secondary color for selection of multiple Child
controls.
Added logic to move siblings (other selected objects on
the same Parent) when a selected object is moved.
Eliminated TOverlay mechanism for rubberbanding; now using
WINAPI calls with GetDC(0).
Added a Lock property to disable move/resize.
Started adding a snap-to grid mechanism (GridX, GridY & SnapToGrid
properties); needs more work, though.
Anthony Scott
CIS: 75567,3547 }
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Menus, StdCtrls;
{ miscellaneous type declarations }
type
TDragStyle = (dsMove, dsSizeTopLeft, dsSizeTopRight, dsSizeBottomLeft, dsSizeBottomRight,
dsSizeTop, dsSizeLeft, dsSizeBottom, dsSizeRight);
EBadChild = class(Exception);
{ TStretchHandle component declaration }
type
GridValues = 1..100;
TStretchHandle = class(TCustomControl)
private
FDragOffset: TPoint;
FDragStyle: TDragStyle;
FDragging: boolean;
FDragRect: TRect;
FLocked: boolean;
FColor: TColor;
FPrimaryColor: TColor;
FSecondaryColor: TColor;
FGridX, FGridY: GridValues;
FChildControl: TControl;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMGetDLGCode(var Message: TMessage); message WM_GETDLGCODE;
procedure SetChildControl(ChildControl: TControl);
procedure MoveSiblings(XOffset, YOffset: integer);
procedure Rubberband(NewRect: TRect);
function HasSiblings: boolean;
function GetChildControl: TControl;
function GetModifiedRect(XPos, YPos: integer): TRect;
protected
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure KeyDown(var key: Word; Shift: TShiftState); override;
procedure Paint; override;
property Canvas;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure CreateParams(var Params: TCreateParams); override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
procedure BringToFront;
procedure SendToBack;
procedure Attach(ChildControl: TControl);
procedure Detach;
procedure SetColors(Color1, Color2: TColor);
procedure SwitchColor;
procedure SetGridState(Value: boolean);
function GetGridState: boolean;
function IsAttached: boolean;
{ new run-time only properties }
property Child: TControl read GetChildControl write SetChildControl;
property Attached: boolean read IsAttached;
published
{ new properties }
property Color: TColor read FPrimaryColor write FPrimaryColor default clBlack;
property SecondaryColor: TColor read FSecondaryColor write FSecondaryColor default clGray;
property Locked: boolean read FLocked write FLocked default False;
property GridX: GridValues read FGridX write FGridX default 8;
property GridY: GridValues read FGridY write FGridY default 8;
property SnapToGrid: boolean read GetGridState write SetGridState default False;
{ inherited properties }
property DragCursor;
property Enabled;
property Hint;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
{ defined events }
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnKeyDown;
property OnKeyPress;
end;
procedure Register;
implementation
procedure Register;
begin
{ add the component to the 'Samples' tab }
RegisterComponents('Samples', [TStretchHandle]);
end;
constructor TStretchHandle.Create(AOwner: TComponent);
var
i: integer;
Found: boolean;
begin
inherited Create(AOwner);
{ initialize default properties }
Width := 24;
Height := 24;
FChildControl := nil;
FPrimaryColor := clBlack;
FSecondaryColor := clGray;
{ a value of 1 is used to turn off the snap-to grid }
FGridX := 1;
FGridY := 1;
{ doesn't do anything until it is Attached to something else }
Enabled := False;
Visible := False;
Found := False;
end;
destructor TStretchHandle.Destroy;
begin
inherited Destroy;
end;
procedure TStretchHandle.CreateParams(var Params: TCreateParams);
begin
{ set default Params values }
inherited CreateParams(Params);
{ then add transparency }
Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
end;
procedure TStretchHandle.Attach(ChildControl: TControl);
var
i: integer;
begin
{ definitely not allowed! }
if ChildControl is TForm then
raise EBadChild.Create('Handles can not be attached to this component');
{ auto-detach if still attached (bad dog!); also detaches if Child = nil }
if Attached then
Detach;
if (ChildControl <> nil) then
begin
{ allows StretchHandle to manage the child control's size & position }
FChildControl := ChildControl;
{ honour the lineage }
Parent := ChildControl.Parent;
SetBounds(ChildControl.Left - 2, ChildControl.Top - 2, ChildControl.Width + 5, ChildControl.Height + 5);
{ look for siblings, set up secondary colors if any found }
FColor := FPrimaryColor;
for i := 0 to Parent.ControlCount - 1 do
if Parent.Controls[i] is TStretchHandle then
begin
if (TStretchHandle(Parent.Controls[i]).Attached) and (TStretchHandle(Parent.Controls[i]) <> Self) then
begin
FColor := FSecondaryColor;
TStretchHandle(Parent.Controls[i]).SwitchColor;
end;
end;
{ only make it visible now, to avoid color flashing, & accept events }
FDragRect := Rect(0, 0, 0, 0);
Enabled := True;
Visible := True;
{ use old BringToFront so as not to change Child's Z-order }
if not (csDesigning in ComponentState) then
begin
inherited BringToFront;
SetFocus;
end;
end;
end;
procedure TStretchHandle.Detach;
begin
{ disable & hide StretchHandle }
FChildControl := nil;
FLocked := False;
Enabled := False;
Visible := False;
Parent := nil;
FDragRect := Rect(0, 0, 0, 0);
end;
procedure TStretchHandle.SetColors(Color1, Color2: TColor);
begin
{ set single/multiple select colors }
FPrimaryColor := Color1;
FSecondaryColor := Color2;
{ presume (in case it is already attached)... }
if HasSiblings then
FColor := FSecondaryColor
else
FColor := FPrimaryColor;
end;
procedure TStretchHandle.SwitchColor;
begin
{ set secondary color (may be invoked by siblings) }
FColor := FSecondaryColor;
end;
procedure TStretchHandle.SetChildControl(ChildControl: TControl);
begin
if (ChildControl <> nil) then
Attach(ChildControl)
else
Detach;
end;
function TStretchHandle.GetChildControl: TControl;
begin
Result := FChildControl;
end;
function TStretchHandle.HasSiblings: boolean;
var
i: integer;
begin
{ find out if there is at least one sibling }
Result := False;
for i := 0 to Parent.ControlCount - 1 do
if (Parent.Controls[i] is TStretchHandle) and (TStretchHandle(Parent.Controls[i]) <> Self) then
begin
Result := True;
break;
end;
end;
procedure TStretchHandle.SetGridState(Value: boolean);
begin
{ a value of 1 effectively disables a grid axis }
if Value then
begin
FGridX := 8;
FGridY := 8;
end
else
begin
FGridX := 1;
FGridY := 1;
end;
end;
function TStretchHandle.GetGridState: boolean;
begin
if (FGridX > 1) or (FGridY > 1) then
Result := True
else
Result := False;
end;
function TStretchHandle.IsAttached: boolean;
begin
if FChildControl <> nil then
Result := True
else
Result := False;
end;
procedure TStretchHandle.WMGetDLGCode(var Message: TMessage);
begin
{ completely fake erase, don't call inherited, don't collect $200 }
Message.Result := DLGC_WANTARROWS;
end;
procedure TStretchHandle.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
{ completely fake erase, don't call inherited, don't collect $200 }
Message.Result := 1;
end;
procedure TStretchHandle.MouseMove(Shift: TShiftState; X, Y: Integer);
var
ARect, BRect: TRect;
DragStyle: TDragStyle;
begin
{ default to move cursor unless near a drag box }
DragStyle := dsMove;
Cursor := DragCursor;
{ disallow resize if siblings present }
if not HasSiblings then
begin
ARect := GetClientRect;
{ so I don't like long nested if statements... }
if ((Abs(X - ARect.Left) < 5) and (Abs(Y - ARect.Top) < 5)) then
begin
DragStyle := dsSizeTopLeft;
Cursor := crSizeNWSE;
end;
if ((Abs(X - ARect.Right) < 5) and (Abs(Y - ARect.Bottom) < 5)) then
begin
DragStyle := dsSizeBottomRight;
Cursor := crSizeNWSE;
end;
if ((Abs(X - ARect.Right) < 5) and (Abs(Y - ARect.Top) < 5)) then
begin
DragStyle := dsSizeTopRight;
Cursor := crSizeNESW;
end;
if ((Abs(X - ARect.Left) < 5) and (Abs(Y - ARect.Bottom) < 5)) then
begin
DragStyle := dsSizeBottomLeft;
Cursor := crSizeNESW;
end;
if ((Abs(X - trunc(ARect.Right - ARect.Left) / 2) < 3) and (Abs(Y - ARect.Top) < 5)) then
begin
DragStyle := dsSizeTop;
Cursor := crSizeNS;
end;
if ((Abs(X - trunc(ARect.Right - ARect.Left) / 2) < 3) and (Abs(Y - ARect.Bottom) < 5)) then
begin
DragStyle := dsSizeBottom;
Cursor := crSizeNS;
end;
if ((Abs(Y - trunc(ARect.Bottom - ARect.Top) / 2) < 3) and (Abs(X - ARect.Left) < 5)) then
begin
DragStyle := dsSizeLeft;
Cursor := crSizeWE;
end;
if ((Abs(Y - trunc(ARect.Bottom - ARect.Top) / 2) < 3) and (Abs(X - ARect.Right) < 5)) then
begin
DragStyle := dsSizeRight;
Cursor := crSizeWE;
end;
end;
if FDragging then
begin
{ adjust for snap-to grid (with offset for Child's position) }
if FGridX > 1 then
X := (X DIV FGridX) * FGridX - 2;
if FGridY > 1 then
Y := (Y DIV FGridY) * FGridY - 2;
{ disallow drag off Parent }
if (Left + X) < 0 then
X := -Left;
if (Top + Y) < 0 then
Y := -Top;
if (Left + X) > Parent.Width then
X := Parent.Width - Left;
if (Top + Y) > Parent.Height then
Y := Parent.Height - Top;
{ display drag outline }
RubberBand(GetModifiedRect(X, Y));
end
else
FDragStyle := DragStyle;
{ if position-locked, override cursor change }
if FLocked then
Cursor := crNoDrop;
{ perform default processing }
inherited MouseMove(Shift, X, Y);
end;
procedure TStretchHandle.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if (Button = mbLeft) and not FLocked then
begin
{ adjust for snap-to grid (with offset for Child's position) }
if FGridX > 1 then
X := (X DIV FGridX) * FGridX - 2;
if FGridY > 1 then
Y := (Y DIV FGridY) * FGridY - 2;
{ save position relative to Canvas, & which corner/side to drag }
FDragOffset := Point(X, Y);
FDragging := True;
RubberBand(GetModifiedRect(X, Y));
end;
{ perform default processing }
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TStretchHandle.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
ARect: TRect;
begin
if Button = mbLeft then
begin
{ adjust for snap-to grid (with offset for Child's position) }
if FGridX > 1 then
X := (X DIV FGridX) * FGridX - 2;
if FGridY > 1 then
Y := (Y DIV FGridY) * FGridY - 2;
{ disallow drop off Parent }
if (Left + X) < 0 then
X := -Left;
if (Top + Y) < 0 then
Y := -Top;
if (Left + X) > Parent.Width then
X := Parent.Width - Left;
if (Top + Y) > Parent.Height then
Y := Parent.Height - Top;
if FDragging then
begin
{ obtain new coordinates }
ARect := GetModifiedRect(X, Y);
RubberBand(Rect(0, 0, 0, 0));
{ force Paint when size doesn't change but position does }
if (ARect.Left <> Left) or (ARect.Top <> Top) then
Invalidate;
{ if this was a move, first move siblings }
if FDragStyle = dsMove then
MoveSiblings(ARect.Left - Left, ARect.Top - Top);
{ resize, reposition if anything changed }
SetBounds(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
FDragging := False;
{ seem to need this for keyboard events }
SetFocus;
end;
ReleaseCapture;
end;
{ perform default processing }
inherited MouseUp(Button, Shift, X, Y);
end;
procedure TStretchHandle.KeyDown(var Key: Word; Shift: TShiftState);
begin
{ process arrow keys to move/resize Handles & Child, also move siblings }
case Key of
VK_UP:
begin
if FChildControl <> nil then
FChildControl.Invalidate;
Invalidate;
SetBounds(Left, Top - 1, Width, Height);
MoveSiblings(0, -1);
end;
VK_DOWN:
begin
if FChildControl <> nil then
FChildControl.Invalidate;
Invalidate;
SetBounds(Left, Top + 1, Width, Height);
MoveSiblings(0, 1);
end;
VK_LEFT:
begin
if FChildControl <> nil then
FChildControl.Invalidate;
Invalidate;
SetBounds(Left - 1, Top, Width, Height);
MoveSiblings(-1, 0);
end;
VK_RIGHT:
begin
if FChildControl <> nil then
FChildControl.Invalidate;
Invalidate;
SetBounds(Left + 1, Top, Width, Height);
MoveSiblings(1, 0);
end;
end;
inherited KeyDown(Key, Shift);
end;
function TStretchHandle.GetModifiedRect(XPos, YPos: integer): TRect;
var
ARect: TRect;
begin
{ compute new position/size, depending on FDragStyle}
case FDragStyle of
dsSizeTopLeft:
begin
ARect.Left := Left + (XPos - FDragOffset.X);
ARect.Top := Top + (YPos - FDragOffset.Y);
ARect.Right := Width - (ARect.Left - Left);
ARect.Bottom := Height - (ARect.Top - Top);
end;
dsSizeTopRight:
begin
ARect.Left := Left;
ARect.Top := Top + (YPos - FDragOffset.Y);
ARect.Right := Width + (XPos - FDragOffset.X);
ARect.Bottom := Height - (ARect.Top - Top);
end;
dsSizeBottomLeft:
begin
ARect.Left := Left + (XPos - FDragOffset.X);
ARect.Top := Top;
ARect.Right := Width - (ARect.Left - Left);
ARect.Bottom := Height + (YPos - FDragOffset.Y);
end;
dsSizeBottomRight:
begin
ARect.Left := Left;
ARect.Top := Top;
ARect.Right := Width + (XPos - FDragOffset.X);
ARect.Bottom := Height + (YPos - FDragOffset.Y);
end;
dsSizeTop:
begin
ARect.Left := Left;
ARect.Top := Top + (YPos - FDragOffset.Y);
ARect.Right := Width;
ARect.Bottom := Height - (ARect.Top - Top);
end;
dsSizeBottom:
begin
ARect.Left := Left;
ARect.Top := Top;
ARect.Right := Width;
ARect.Bottom := Height + (YPos - FDragOffset.Y);
end;
dsSizeLeft:
begin
ARect.Left := Left + (XPos - FDragOffset.X);
ARect.Top := Top;
ARect.Right := Width - (ARect.Left - Left);
ARect.Bottom := Height;
end;
dsSizeRight:
begin
ARect.Left := Left;
ARect.Top := Top;
ARect.Right := Width + (XPos - FDragOffset.X);
ARect.Bottom := Height;
end;
else
{ keep size, move to new position }
ARect.Left := Left + (XPos - FDragOffset.X);
ARect.Top := Top + (YPos - FDragOffset.Y);
ARect.Right := Width;
ARect.Bottom := Height;
end;
{ impose a minimum size for sanity }
if ARect.Right < 5 then
ARect.Right := 5;
if ARect.Bottom < 5 then
ARect.Bottom := 5;
Result := ARect;
end;
procedure TStretchHandle.Rubberband(NewRect: TRect);
var
PtA, PtB: TPoint;
ScreenDC: HDC;
begin
ScreenDC := GetDC(0);
{ erase previous rectangle, if any, & adjust for handle's position }
PtA := Parent.ClientToScreen(Point(FDragRect.Left + 2, FDragRect.Top + 2));
PtB := Parent.ClientToScreen(Point(FDragRect.Left + FDragRect.Right - 3, FDragRect.Top + FDragRect.Bottom - 3));
if (FDragRect.Left <> 0) or (FDragRect.Top <> 0) or (FDragRect.Right <> 0) or (FDragRect.Bottom <> 0) then
DrawFocusRect(ScreenDC, Rect(PtA.X, PtA.Y, PtB.X, PtB.Y));
{ draw new rectangle }
PtA := Parent.ClientToScreen(Point(NewRect.Left + 2, NewRect.Top + 2));
PtB := Parent.ClientToScreen(Point(NewRect.Left + NewRect.Right - 3, NewRect.Top + NewRect.Bottom - 3));
if (NewRect.Left <> 0) or (NewRect.Top <> 0) or (NewRect.Right <> 0) or (NewRect.Bottom <> 0) then
DrawFocusRect(ScreenDC, Rect(PtA.X, PtA.Y, PtB.X, PtB.Y));
FDragRect := NewRect;
ReleaseDC(0, ScreenDC);
end;
procedure TStretchHandle.BringToFront;
begin
{ take care of Child first }
if FChildControl <> nil then
FChildControl.BringToFront;
inherited BringToFront;
SetFocus;
end;
procedure TStretchHandle.SendToBack;
begin
{ only child goes to back! }
if FChildControl <> nil then
FChildControl.SendToBack;
inherited BringToFront;
SetFocus;
end;
procedure TStretchHandle.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
WasVisible: boolean;
begin
{ hide & preserve fixed size in design mode }
WasVisible := Visible;
if csDesigning in ComponentState then
begin
Visible := False;
inherited SetBounds(ALeft, ATop, 24, 24);
end
else { move child also, if any (but only if not locked) }
if not FLocked then
begin
if FChildControl <> nil then
FChildControl.SetBounds(ALeft + 2, ATop + 2, AWidth - 5, AHeight - 5);
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;
{ restore visibility }
if Visible = False then
Visible := WasVisible;
end;
procedure TStretchHandle.MoveSiblings(XOffset, YOffset: integer);
var
i, T, L, W, H: integer;
begin
{ look for siblings, adjust their position by FDropOffset }
for i := 0 to Parent.ControlCount - 1 do
if Parent.Controls[i] is TStretchHandle then
begin
if (TStretchHandle(Parent.Controls[i]).Attached) and (TStretchHandle(Parent.Controls[i]) <> Self) then
begin
L := TStretchHandle(Parent.Controls[i]).Left + XOffset;
T := TStretchHandle(Parent.Controls[i]).Top + YOffset;
W := TStretchHandle(Parent.Controls[i]).Width;
H := TStretchHandle(Parent.Controls[i]).Height;
TStretchHandle(Parent.Controls[i]).Invalidate;
TStretchHandle(Parent.Controls[i]).SetBounds(L, T, W, H);
end;
end;
end;
procedure TStretchHandle.Paint;
var
ARect, BoxRect: TRect;
begin
inherited Paint;
ARect := Rect(0, 0, Width - 1, Height - 1);
with Canvas do
begin
Brush.Color := FColor;
{ draw corner boxes (assuming Canvas is minimum 5x5) }
BoxRect := Rect(ARect.Left, ARect.Top, ARect.Left + 5, ARect.Top + 5);
FillRect(BoxRect);
BoxRect := Rect(ARect.Right - 5, ARect.Top, ARect.Right, ARect.Top + 5);
FillRect(BoxRect);
BoxRect := Rect(ARect.Right - 5, ARect.Bottom - 5, ARect.Right, ARect.Bottom);
FillRect(BoxRect);
BoxRect := Rect(ARect.Left, ARect.Bottom - 5, ARect.Left + 5, ARect.Bottom);
FillRect(BoxRect);
{ draw center boxes (favouring 1 pixel to the right for even sides) }
BoxRect := Rect(trunc((ARect.Right - ARect.Left) / 2) - 2,
ARect.Top,
trunc((ARect.Right - ARect.Left) / 2) + 3,
ARect.Top + 5);
FillRect(BoxRect);
BoxRect := Rect(trunc((ARect.Right - ARect.Left) / 2) - 2,
ARect.Bottom - 5,
trunc((ARect.Right - ARect.Left) / 2) + 3,
ARect.Bottom);
FillRect(BoxRect);
BoxRect := Rect(ARect.Left,
trunc((ARect.Bottom - ARect.Top) / 2) - 2,
ARect.Left + 5,
trunc((ARect.Bottom - ARect.Top) / 2) + 3);
FillRect(BoxRect);
BoxRect := Rect(ARect.Right - 5,
trunc((ARect.Bottom - ARect.Top) / 2) - 2,
ARect.Right,
trunc((ARect.Bottom - ARect.Top) / 2) + 3);
FillRect(BoxRect);
end;
end;
end.